home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Memphis Amiga Group
/
MAG Disk (1989-11)(Memphis Amiga Group).zip
/
MAG Disk (1989-11)(Memphis Amiga Group).adf
/
HeadClean
/
headclean.f
< prev
next >
Wrap
Text File
|
1986-11-06
|
7KB
|
246 lines
\ Clean a drive by trying to format several cylinders
\ on a fibre cleaning disk
\ The last cylinder used will be kept in a file called
\ HEADCLEAN.LOG
\ Author: Phil Burk
\ Copyright 1987,8,9 Phil Burk
\
\ This program is a freely redistributable shareware program.
\ Files from HeadClean Directory
include? td.format disk_support
include? tdt.init disk_tools
include? gt.process.events gadget_tools
include? $hc.msg hc_base
include? drive.buttons.init hc_drive_gads
ANEW TASK-HeadClean
\ ----------------------------------------------------
\ Graphical User Interface Portion of code.
\ Support for GO gadget.
: HC.ALL.USED ( -- )
" This disk is used up. You may want to buy a new one."
$HC.MSG
0 clean-start !
;
: CHECK.START ( -- , correct start cylinder if bad )
clean-start @ NUMCYLS 1- clean_#cyl - >
IF hc.all.used
THEN
;
: HC.GO ( -- , clean disk
check.start
<headclean>
check.start
;
\ ------------------------------------------------
\ Support for HELP gadget.
variable HC-CURY
: HC.LINE ( text -- , new line of graphics )
10 hc-cury @ gr.move
gr.text
hc_line_height hc-cury +!
;
variable HC-WINDOW
: HC.HELP.TEXT1 ( -- , display first help screen )
1 gr.color!
hc_banner_y1 hc-cury ! ( set y pos )
" HeadClean V2.0 is designed to work with any fibre" hc.line
" cleaning disk. Read directions for your cleaning" hc.line
" disk first. Then apply cleaning liquid and place" hc.line
" disk in drive to be cleaned. Then select drive" hc.line
" with mouse and select 'GO!'. Every cleaning will" hc.line
" use 4 cylinders of the disk. The next cylinder" hc.line
" to use will be written to the file HeadClean.LOG." hc.line
" When every cylinder has been used you may want" hc.line
" to buy a new cleaning disk, or keep using it over" hc.line
" and over. Clean your heads after every 40 hours" hc.line
" of use, or if you start getting Read/Write errors." hc.line
" " hc.line
" Click in CloseBox to continue" hc.line
;
: HC.HELP.TEXT2 ( -- )
gr.clear
1 gr.color!
hc_banner_y1 hc-cury !
" HeadClean was written using JForth Professional 2.0," hc.line
" a powerful and fast interactive programming language." hc.line
" For more information, write or phone:" hc.line
3 gr.color!
" " hc.line
" Delta Research" hc.line
" P.O. Box 1051" hc.line
" San Rafael, CA, 94915" hc.line
" (415) 485-6867" hc.line
" " hc.line
1 gr.color!
" HeadClean V2.0 is shareware. If you find this" hc.line
" program useful please send a check for $10.00" hc.line
" payable to Phil Burk at the above address." hc.line
" HeadClean V2.0 may be freely restributed." hc.line
;
newWindow HC-NewWindow
: HC.HELP ( -- , Draw explanatory help in separate window )
hc-newwindow newwindow.setup
hc_window_w hc-NewWindow ..! nw_width
160 hc-NewWindow ..! nw_height
\ Set new title.
0" HeadClean Help"
>abs hc-NewWindow ..! nw_title
\
hc-NewWindow gr.opencurw
IF hc.help.text1
BEGIN ?closebox
UNTIL
hc.help.text2
BEGIN ?closebox
UNTIL
gr.closecurw
\
hc-window @ ?dup
IF gr.set.curwindow
THEN
ELSE " Insufficient memory for HELP window!" $hc.msg
THEN
;
\ Main Graphics support --------------------------------
: HC.DRAW.BANNER ( -- )
1 gr.color!
hc_banner_y1 hc-cury !
" Written by Phil Burk using JForth Professional 2.0"
hc.line
" from Delta Research, Box 1051, San Rafael, CA, 94915"
hc.line
" Select which drive to clean, then hit 'GO!'."
hc.line
;
: HC.REDRAW ( -- , redraw graphics )
gr.clear
1 gr.color!
hc.draw.banner
hc.report.left
hc.show.drive
gt.refresh
;
: HC.GADS.INIT ( -- , initialize gadgets for demo )
\ define border of gadgets.
boolg-xys >abs boolg-border ..! bd_xy
hc_w_h boolg-border border.setup
\
\ Declare text, CFA, and size for each gadget.
0 first-gadget !
' hc.go 0" Go!"
hc_gadget_x hc_gadget_inc 5 * + hc_gadget_y hc_w_h gt.gad.make
' hc.help 0" Help"
hc_gadget_x hc_gadget_inc 6 * + hc_gadget_y hc_w_h gt.gad.make
\
drive.buttons.init
\
\ Set defaults for newwindow
hc-NewWindow newwindow.setup
hc_window_w hc-NewWindow ..! nw_width
hc_window_h hc-NewWindow ..! nw_height
\
\ Link gadget list to window.
first-gadget @ >abs hc-NewWindow ..! nw_firstgadget
\
\ Set new title.
0" -< HeadClean V2.0 -- Shareware >-"
>abs hc-NewWindow ..! nw_title
\
\ Set flags for gadget events.
CLOSEWINDOW GADGETDOWN | GADGETUP |
hc-NewWindow ..! nw_idcmpflags
;
: HC.LOOP ( -- , process mouse events until done )
BEGIN
gr-curwindow @ ev.wait
gr-curwindow @ ev.getclass dup
IF gt.process.event ( -- done? )
THEN
UNTIL
;
\ Read and write starting cylinder to a log file --------------
: HC_FILENAME ( -- $name )
" RAM:HeadClean.log"
;
: HC.READ.START ( -- , read start from log file or set to -1 )
hc_filename $fopen ?dup
IF dup clean-start 4 fread 4 - ( unformatted 4 byte read )
IF " Could not find HeadClean.log file. Start at 0"
$HC.MSG
0 clean-start !
THEN
fclose
ELSE " Could not find HeadClean.log file. Start at 0"
$HC.MSG
0 clean-start !
THEN
;
: HC.WRITE.START ( -- , write start to log file or set to -1 )
new hc_filename $fopen ?dup
IF dup clean-start 4 fwrite drop ( unformatted 4 byte read )
fclose
THEN
;
\ Main control words ----------------------------
\ I strongly recommend structuring your programs
\ with a separate INIT and TERM word
\ and a simple Main word that does both.
\ This greatly simplifies testing bacause
\ you can INIT completely then test interactively
\ withou running the program.
: HC.INIT ( -- ok? , initialize EVERYTHING )
gr.init
hc.gads.init
hc-NewWindow gr.opencurw dup
IF gr-curwindow @ hc-window !
hc.read.start
check.start
arrow.init
0 hc.drive
hc.redraw
THEN
;
: HC.TERM ( -- , clean up SAFELY )
arrow.term
gr.closecurw
hc-window off
hc.write.start
gt.free.all
;
: HEADCLEAN ( -- , main entry point )
hc.init
IF hc.loop
THEN
hc.term
;
\ Automatically clean up if FORGET used.
if.forgotten HC.TERM
cr ." Enter: HEADCLEAN to clean drive heads." cr